home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gnu / adainc / s-os2~tp.adb < prev    next >
Text File  |  1996-01-30  |  16KB  |  550 lines

  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS                --
  4. --                                                                          --
  5. --                S Y S T E M . T A S K _ P R I M I T I V E S               --
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                               (OS/2 Version)                             --
  9. --                                                                          --
  10. --                             $Revision: 1.4 $                             --
  11. --                                                                          --
  12. --             Copyright (c) 1993,1994 NYU, All Rights Reserved             --
  13. --                                                                          --
  14. --  GNARL is free software; you can redistribute it and/or modify it  under --
  15. --  terms  of  the  GNU  Library General Public License as published by the --
  16. --  Free Software Foundation; either version 2,  or (at  your  option)  any --
  17. --  later  version.   GNARL is distributed in the hope that it will be use- --
  18. --  ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
  19. --  MERCHANTABILITY  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  20. --  eral Library Public License for more details.  You should have received --
  21. --  a  copy of the GNU Library General Public License along with GNARL; see --
  22. --  file COPYING. If not, write to the Free Software Foundation,  675  Mass --
  23. --  Ave, Cambridge, MA 02139, USA.                                          --
  24. --                                                                          --
  25. ------------------------------------------------------------------------------
  26.  
  27. with Interfaces.C.Strings;    use Interfaces.C.Strings;
  28. with System.Address_To_Access_Conversions;
  29. with System.OS2Lib;           use System.OS2Lib;
  30. with System.OS2Lib.Errors;    use System.OS2Lib.Errors;
  31. with System.Storage_Elements; use System.Storage_Elements;
  32. with System.Io;               use System.Io;
  33.  
  34. package body System.Task_Primitives is
  35.  
  36.    Offset : Storage_Offset;
  37.    --  Holds the offset from the base of a thread's stack to the TCB for the
  38.    --  thread. The assumption is that this is the same for all threads. See
  39.    --  description of Self function. Set by Booster.
  40.  
  41.    Thread_1_TCB_Ptr : TCB_Ptr;
  42.    --  Pointer to TCB of main task. We need this because we can't use the
  43.    --  normal self mechanism (with the "booster" trick) for the main task.
  44.    --  See Self procedure for more details.
  45.  
  46.    package Address_TCB_Ptr_Ptr_Conversion is
  47.      new Address_To_Access_Conversions (TCB_Ptr);
  48.  
  49.    package Address_TCB_Ptr_Conversion is
  50.       new Address_To_Access_Conversions (Task_Control_Block);
  51.  
  52.    package Address_Boolean_Conversion is
  53.      new Address_To_Access_Conversions (Boolean);
  54.  
  55.    -------------------------
  56.    -- Initialize_LL_Tasks --
  57.    -------------------------
  58.  
  59.    procedure Initialize_LL_Tasks (T : TCB_Ptr) is
  60.    begin
  61.       T.all := (LL_Entry_Point  => null,
  62.                 LL_Arg          => Null_Address,
  63.                 Thread          => 1,            --  By definition
  64.                 Active_Priority => Default_Priority,
  65.                 Aborted         => False);
  66.  
  67.       Thread_1_TCB_Ptr := T;
  68.    end Initialize_LL_Tasks;
  69.  
  70.    ----------
  71.    -- Self --
  72.    ----------
  73.  
  74.    --  When a task is created, the body of the (OS/2) thread is the
  75.    --  procedure Booster, which in turn calls the actual task body.
  76.    --  Booster has a local variable where the TCB pointer is stored.
  77.  
  78.    --  The assumption is that the offset from the base of the thread's
  79.    --  stack to this variable is always the same; this offset is stored
  80.    --  in the global variable Offset by Booster itself.
  81.  
  82.    --  Therefore, we retrieve the stack pointer as the location at Offset
  83.    --  from the thread's stack base.
  84.  
  85.    --  Note: This does not work for Thread 1, since this one is not created
  86.    --  using the Booster trick. Thread 1 TCB addr is in Thread_1_TCB_Ptr.
  87.  
  88.    function Self return TCB_Ptr is
  89.       use Address_TCB_Ptr_Ptr_Conversion;
  90.  
  91.       Process_Info : aliased PPIB;
  92.       Thread_Info  : aliased PTIB;
  93.  
  94.    begin
  95.       Must_Not_Fail
  96.         (DosGetInfoBlocks (Thread_Info'Access, Process_Info'Access));
  97.  
  98.       if Thread_Info.tib_ptib2.tib2_ultid = 1 then
  99.          return Thread_1_TCB_Ptr;
  100.       else
  101.          return To_Pointer (Thread_Info.tib_pstack + Offset).all;
  102.       end if;
  103.    end Self;
  104.  
  105.    -------------
  106.    -- Booster --
  107.    -------------
  108.  
  109.    --  See description above for Self function
  110.  
  111.    procedure Booster (Info : PVOID);
  112.    procedure Booster (Info : PVOID) is
  113.       use Address_TCB_Ptr_Conversion;
  114.  
  115.       My_TCB_Ptr : TCB_Ptr;
  116.  
  117.    begin
  118.       My_TCB_Ptr := To_Pointer (Info).all'Access;
  119.  
  120.       declare
  121.          Process_Info : aliased PPIB;
  122.          Thread_Info  : aliased PTIB;
  123.       begin
  124.          if DosGetInfoBlocks (Thread_Info'Access, Process_Info'Access)
  125.                                          = NO_ERROR
  126.          then
  127.             Offset := My_TCB_Ptr'Address - Thread_Info.tib_pstack;
  128.          else
  129.             raise Storage_error;
  130.          end if;
  131.       end;
  132.  
  133.       --  Here we go!
  134.  
  135.       My_TCB_Ptr.LL_Entry_Point (My_TCB_Ptr.LL_Arg);
  136.  
  137.    end Booster;
  138.  
  139.    --------------------
  140.    -- Create_LL_Task --
  141.    --------------------
  142.  
  143.    procedure Create_LL_Task
  144.      (Priority       : Priority;
  145.       Stack_Size     : Task_Storage_Size;
  146.       LL_Entry_Point : LL_Task_Procedure_Access;
  147.       Arg            : Address;
  148.       T              : TCB_Ptr)
  149.    is
  150.       use Interfaces.C;
  151.       use Address_TCB_Ptr_Conversion;
  152.  
  153.       Result : OS2Lib.APIRET;
  154.       Id     : aliased TID;
  155.       Junk1  : PVOID; -- TBSL ???
  156.       Junk2  : ULONG; -- TBSL ???
  157.  
  158.    begin
  159.       --  Step 1: Create the thread in blocked mode
  160.  
  161.       Junk1  := Address_TCB_Ptr_Conversion.To_Address (T.all'Access);
  162.       Junk2  := ULONG (Stack_Size);
  163.       Result := DosCreateThread
  164.                    (F_ptid   => Id'Access,
  165.                     pfn      => LL_Task_Procedure_Access'(Booster'Access),
  166.                     param    => Junk1,
  167.                     flag     => 1, -- Block_child + No_commit_stack,
  168.                     cbStack  => Junk2);
  169.       if Result /= NO_ERROR then
  170.          raise Storage_error;
  171.       end if;
  172.  
  173.       --  Step 2: set its TCB
  174.  
  175.       T.all := (LL_Entry_Point => LL_Entry_Point,
  176.                 LL_Arg          => Arg,
  177.                 Thread          => Id,
  178.                 Active_Priority => Priority,
  179.                 Aborted         => False);
  180.  
  181.       --  Step 3: set its priority (child has inherited priority from parent)
  182.  
  183.       Must_Not_Fail
  184.         (DosSetPriority (Scope   => PRTYS_THREAD,
  185.                          Class   => PRTYC_NOCHANGE,
  186.                          Delta_P => long (Priority - Get_Own_Priority),
  187.                          PorTid  => Id));
  188.  
  189.       --  Step 4: Now, start it for good:
  190.  
  191.       Must_Not_Fail (DosResumeThread (Id));
  192.  
  193.    end Create_LL_Task;
  194.  
  195.    ------------------
  196.    -- Exit_LL_Task --
  197.    ------------------
  198.  
  199.    procedure Exit_LL_Task is
  200.    begin
  201.       DosExit (EXIT_THREAD, 0);
  202.    end Exit_LL_Task;
  203.  
  204.    ---------------------
  205.    -- Initialize_Lock --
  206.    ---------------------
  207.  
  208.    procedure Initialize_Lock (Prio : Integer; L : in out Lock) is
  209.    begin
  210.       if DosCreateMutexSem (Null_Ptr, L.Mutex'Access, 0, False32)
  211.                                             /= NO_ERROR
  212.       then
  213.          raise Storage_Error;
  214.       end if;
  215.  
  216.       L.Priority := Prio;
  217.    end Initialize_Lock;
  218.  
  219.    -------------------
  220.    -- Finalize_Lock --
  221.    -------------------
  222.  
  223.    procedure Finalize_Lock (L : in out Lock) is
  224.    begin
  225.       Must_Not_Fail (DosCloseMutexSem (L.Mutex));
  226.    end Finalize_Lock;
  227.  
  228.    ----------------
  229.    -- Write_Lock --
  230.    ----------------
  231.  
  232.    procedure Write_Lock (L : in out Lock; Ceiling_Violation : out Boolean) is
  233.    begin
  234.       L.Owner_Priority := Get_Own_Priority;
  235.  
  236.       if L.Priority < L.Owner_Priority then
  237.          Ceiling_Violation := True;
  238.          return;
  239.       end if;
  240.  
  241.       Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT));
  242.  
  243.       Ceiling_Violation := False;
  244.  
  245.       if L.Priority > L.Owner_Priority then
  246.          Set_Own_Priority (L.Priority);
  247.       end if;
  248.    end Write_Lock;
  249.  
  250.    ---------------
  251.    -- Read_Lock --
  252.    ---------------
  253.  
  254.    --  Not worth worrying about distinguishing read and write locks until
  255.    --  OS/2 supports multi-processing, since no advantage would be gained.
  256.  
  257.    procedure Read_Lock (L : in out Lock; Ceiling_Violation : out Boolean)
  258.       renames Write_Lock;
  259.  
  260.    ------------
  261.    -- Unlock --
  262.    ------------
  263.  
  264.    procedure Unlock (L : in out Lock) is
  265.    begin
  266.       if L.Owner_Priority /= L.Priority then
  267.          Set_Own_Priority (L.Owner_Priority);
  268.       end if;
  269.  
  270.       Must_Not_Fail (DosReleaseMutexSem (L.Mutex));
  271.    end Unlock;
  272.  
  273.    -----------------------
  274.    -- Initalialize_Cond --
  275.    -----------------------
  276.  
  277.    procedure Initialize_Cond (Cond : in out Condition_Variable) is
  278.       Temporary : aliased HEV;
  279.       --  This temporary is needed for two reasons:
  280.       --  1) Since DosCreateSem operates on an PHEV, not HEV, it is not
  281.       --     derived and thus not available on type Condition_variable.
  282.       --  2) Moreover we cannot have an aliased view of Cond, required
  283.       --     for 'Access.
  284.  
  285.    begin
  286.       Must_Not_Fail
  287.         (DosCreateEventSem (Null_Ptr, Temporary'Access, 0, True32));
  288.       Cond := Condition_Variable (Temporary);
  289.    end Initialize_Cond;
  290.  
  291.    -------------------
  292.    -- Finalize_Cond --
  293.    -------------------
  294.  
  295.    --  No such problem here, DosCloseEventSem has been derived.
  296.    --  What does such refer to in above comment???
  297.  
  298.    procedure Finalize_Cond (Cond : in out Condition_Variable) is
  299.    begin
  300.       Must_Not_Fail (DosCloseEventSem (Cond));
  301.    end Finalize_Cond;
  302.  
  303.    ---------------
  304.    -- Cond_Wait --
  305.    ---------------
  306.  
  307.    --  Pre-assertion: Cond is posted
  308.    --                 L is locked.
  309.  
  310.    --  Post-assertion: Cond is posted
  311.    --                  L is locked.
  312.  
  313.    procedure Cond_Wait
  314.      (Cond : in out Condition_Variable;
  315.       L    : in out Lock)
  316.    is
  317.       Count : aliased ULONG; -- Unused
  318.       Error : Boolean;
  319.    begin
  320.       --  Must reset Cond BEFORE L is unlocked.
  321.  
  322.       Must_Not_Fail (DosResetEventSem (Cond, Count'Access));
  323.       Unlock (L);
  324.  
  325.       --  No problem if we are interrupted here: if the condition is signaled,
  326.       --  DosWaitEventSem will simply not block
  327.  
  328.       Must_Not_Fail (DosWaitEventSem (Cond, SEM_INDEFINITE_WAIT));
  329.  
  330.       --  Since L was previously accquired, Error cannot be false:
  331.       Write_Lock (L, Error);
  332.    end Cond_Wait;
  333.  
  334.    ---------------------
  335.    -- Cond_Timed_Wait --
  336.    ---------------------
  337.  
  338.    --  Pre-assertion: Cond is posted
  339.    --                 L is locked.
  340.  
  341.    --  Post-assertion: Cond is posted
  342.    --                  L is locked.
  343.  
  344.    procedure Cond_Timed_Wait
  345.      (Cond      : in out Condition_Variable;
  346.       L         : in out Lock;
  347.       Abs_time  : System.Task_Clock.Stimespec;
  348.       Timed_Out : out Boolean)
  349.    is
  350.       use System.Task_Clock;
  351.  
  352.       Count    : aliased ULONG; -- Unused
  353.       Time_Out : ULONG;
  354.       Error    : Boolean;
  355.  
  356.    begin
  357.       --  Must reset Cond BEFORE L is unlocked.
  358.  
  359.       Must_Not_Fail (DosResetEventSem (Cond, Count'Access));
  360.       Unlock (L);
  361.  
  362.       --  No problem if we are interrupted here: if the condition is signaled,
  363.       --  DosWaitEventSem will simply not block
  364.  
  365.       Time_Out := ULONG (Stimespec_Seconds  (Abs_Time)) +
  366.                   ULONG (Stimespec_NSeconds (Abs_Time) / 1E7);
  367.       Timed_Out :=  DosWaitEventSem (Cond, Time_Out) = ERROR_SEM_TIMEOUT;
  368.  
  369.       --  Since L was previously accquired, Error cannot be false:
  370.       Write_Lock (L, Error);
  371.  
  372.       --  Ensure post-condition
  373.  
  374.       if Timed_Out then
  375.          Must_Not_Fail (DosPostEventSem (Cond));
  376.       end if;
  377.    end Cond_Timed_Wait;
  378.  
  379.    -----------------
  380.    -- Cond_Signal --
  381.    -----------------
  382.  
  383.    procedure Cond_Signal (Cond : in out Condition_Variable) is
  384.    begin
  385.       Must_Not_Fail (DosPostEventSem (Cond));
  386.    end Cond_Signal;
  387.  
  388.    ------------------
  389.    -- Set_Priority --
  390.    ------------------
  391.  
  392.    --  Note: Currently, we have only 32 priorities, all in Regular Class.
  393.    --  Priority level 31 is the only value for Interrupt_Priority. (see
  394.    --  package System). A better choice (for OS/2) would be to have 32
  395.    --  priorities in Regular class for subtype Priority and 32 priorities
  396.    --  in Time-critical class for Interrupt_Priority ???
  397.  
  398.    procedure Set_Priority (T : TCB_Ptr; Prio : Integer) is
  399.       use Interfaces.C;
  400.  
  401.    begin
  402.       Must_Not_Fail
  403.         (DosSetPriority (Scope   => PRTYS_THREAD,
  404.                          Class   => PRTYC_NOCHANGE,
  405.                          Delta_P => long (Prio - T.Active_Priority),
  406.                          PorTid  => T.Thread));
  407.       T.Active_Priority := Prio;
  408.    end Set_Priority;
  409.  
  410.    ----------------------
  411.    -- Set_Own_Priority --
  412.    ----------------------
  413.  
  414.    procedure Set_Own_Priority (Prio : Integer) is
  415.    begin
  416.       Set_Priority (Self, Prio);
  417.    end Set_Own_Priority;
  418.  
  419.    ------------------
  420.    -- Get_Priority --
  421.    ------------------
  422.  
  423.    function Get_Priority (T : TCB_Ptr) return Integer is
  424.    begin
  425.       return T.Active_Priority;
  426.    end Get_Priority;
  427.  
  428.    ----------------------
  429.    -- Get_Own_Priority --
  430.    ----------------------
  431.  
  432.    function Get_Own_Priority return Integer is
  433.    begin
  434.       return Get_Priority (Self);
  435.    end Get_Own_Priority;
  436.  
  437.  
  438.    ----------------
  439.    -- Abort_Task --
  440.    ----------------
  441.  
  442.    procedure Abort_Task (T : TCB_Ptr) is
  443.    begin
  444.       T.Aborted := True;
  445.    end Abort_Task;
  446.  
  447.    ----------------
  448.    -- Test_Abort --
  449.    ----------------
  450.  
  451.    Current_Abort_Handler : Abort_Handler_Pointer;
  452.  
  453.    procedure Test_Abort is
  454.    begin
  455.       if Self.Aborted then
  456.          Current_Abort_Handler (0);   -- Parameter not used
  457.       end if;
  458.    end Test_Abort;
  459.  
  460.    ---------------------------
  461.    -- Install_Abort_Handler --
  462.    ---------------------------
  463.  
  464.    procedure Install_Abort_Handler (Handler : Abort_Handler_Pointer) is
  465.    begin
  466.       Current_Abort_Handler := Handler;
  467.    end Install_Abort_Handler;
  468.  
  469.  
  470.    ---------------------------
  471.    -- Install_Error_Handler --
  472.    ---------------------------
  473.  
  474.    procedure Install_Error_Handler (Handler : Address) is
  475.    begin
  476.       null;
  477.    end Install_Error_Handler;
  478.  
  479.    -----------------
  480.    -- Signal_Task --
  481.    -----------------
  482.  
  483.    procedure Signal_Task (T : TCB_Ptr; I : Interrupt_ID) is
  484.    begin
  485.       raise Program_Error;
  486.    end Signal_Task;
  487.  
  488.    ---------------------
  489.    -- Wait_For_Signal --
  490.    ---------------------
  491.  
  492.    procedure Wait_for_Signal (I : Interrupt_ID) is
  493.    begin
  494.       raise PROGRAM_ERROR;
  495.    end Wait_for_Signal;
  496.  
  497.    ---------------------
  498.    -- Reserved_Signal --
  499.    ---------------------
  500.  
  501.    function Reserved_Signal (I : Interrupt_ID) return Boolean is
  502.    begin
  503.       return False;
  504.    end Reserved_Signal;
  505.  
  506.    ------------------
  507.    -- Test_And_Set --
  508.    ------------------
  509.  
  510.    Test_And_Set_Mutex : Lock;
  511.    --  Lock used by Test_And_Set procedure
  512.  
  513.    procedure Test_And_Set
  514.      (Flag_Add : System.Address;
  515.       Result   : out Boolean)
  516.    is
  517.       use Address_Boolean_Conversion;
  518.       Error : Boolean;
  519.    begin
  520.       Write_Lock (Test_And_Set_Mutex, Error);
  521.  
  522.       if not To_Pointer (Flag_Add).all then
  523.          To_Pointer (Flag_Add).all := True;
  524.          Unlock (Test_And_Set_Mutex);
  525.          Result :=  True;
  526.       else
  527.          Unlock (Test_And_Set_Mutex);
  528.          Result := False;
  529.       end if;
  530.    end Test_And_Set;
  531.  
  532.    ---------------
  533.    -- LL_Assert --
  534.    ---------------
  535.  
  536.    procedure LL_Assert (B : Boolean; M : String) is
  537.    begin
  538.       if not B then
  539.          Put ("Failed assertion: ");
  540.          Put (M);
  541.          Put ('.');
  542.          New_Line;
  543.          pragma Assert (False);
  544.       end if;
  545.    end LL_Assert;
  546.  
  547. begin
  548.    Initialize_Lock (System.Priority'Last, Test_And_Set_Mutex);
  549. end System.Task_Primitives;
  550.